PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/eval_az.com/TESTLIB.PAS

Pascal/Delphi Source File | 1989-07-11 | 22.0 KB | 784 lines

{-  Dataran Standard Library  Special Version for RTU}
{ designed to be used with TP Professional }

{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S-}    {Stack checking on}
{$I-}    {I/O checking on}

Unit testlib;

Interface
uses   Dos;

const
  secs_per_minute = 60;
  secs_per_hour  = 3600;
  secs_per_day = 86400;  { number of sconds in a day }

{ ASCII CHARACTERS }
formfeed  =  ^L;    { formdeed character }
alf       = ^J;    { ascii line feed}
acr       =  ^M;    { ascii carrige return }
aesc      = ^[;     { ascii escape }
adel      = #127;   { ascii delete }
absp      = #8;     { ascii back space }
abell     = #7;     { beep }
aus       = '_';      { ascii underscore }
anak      = #21;      { NAK }
aack      = #6;       { ack }
axon      = #17;      { xon CTRL q }
axoff     = #19;      { xoff ctrl S}

uparrow   = #24;   { graphic arrow keys}
dnarrow   = #25;
larrow    = #27;
rarrow    = #26;

k_esc = $01;  k_bs = $0e;  k_enter = $1c;  k_home = $47;
k_up = $48;  k_pgup = $49;  k_left = $4b;  k_right = $4d;
k_end = $4f;  k_down = $50;  k_pgdn = $51;  k_ins = $52;
k_del = $53;  k_f1 = $3b;  k_f2 = $3c;  k_f3 = $3d;  k_f4 = $3e;

caps   : boolean = false;   { true if upper case only wanted }


{ NUMERIC CONTROLS }
intsmall  = -32767; { a small integer }
intbig    = 32767;    { a big integer }
longbig   =  2147483647;
longsmall = -2147483647;
realsmall = -9999999;
realbig   = 99999999;

type

 regpack = registers;

 halfpack = record
           al,ah,bl,bh,cl,ch,dl,dh : byte;
         end;
 maxstring = string[255];    { the biggest there is }
 anystring = string[140];    { largest general purpose string }
 filename  = string[30];     { tupical file name }
 small_string = string[24];  { save stack space for small strin functions }
 med_string   = string[134]; { long line type string }
 charset    = set of char;

 timestr = string[8];    { holds formatted time as HH:MM:SS }
 datestr = string[8];       { date asMM/DD/YY   }

(*  { old style parser }
  parse_rec = record
    parsed      : array[1..numparse] of string[parselen];  { holds parsed lines }
    com_chr      : char;                                   { comment character }
    sep_chr      : char;            { returns to caller sep char actually used }
    primary_sep : char;            { use this for sep char if found in string }
    option_sep  : char;        { alternate sep char to use if other not found }
    tot_parsed  : integer;                        { number of elements parsed }
    param_start : integer;     { returns position of first item after keyword }
    in_buff     : ^maxstring;   { is set by procedure to point to input source }
  end;
*)


{ parser controls }
const
numparse = 32;   { number of parsed elements}
{  parselen = 60;   { max size of each elemrnt }

type

{ New style parser  using objects }
  parse_type = object
    in_buff     : ^maxstring;  { is set by procedure to point to input source }
    com_chr      : char;        { comment character }
    sep_chr     : char;        { returns to caller sep char actually used }
    primary_sep : char;        { use this for sep char if found in string }
    option_sep  : char;        { alternate sep char to use if other not found }
    tot_len     : integer;     { length of raw line up to any comments}
    tot_parsed  : integer;     { number of elements parsed }
    param_start : integer;     { returns position of first item after keyword }
    starts      : array[1..numparse] of byte;  { starting positions }
    ends        : array[1..numparse] of byte;  { ending positions }
    constructor init;
    procedure parse(var instring: string);

    function parsed(i:integer) : med_string;  { pull out the i'th element }
  end;



var            { variables used by all functions and procedures }
 recpack          : regpack ;  { used to interface with msdos }
 ah,al,ch,cl,dh   : byte;

procedure beep;
procedure blip;


function zfill(zstr : anystring) : anystring;

function time: timestr;    { returns formatted time }
function secs_now  : longint;  { returns number of seconds sice midnite}
function time_now : timestr; { returns string using secs_now  rather than dos}
function num_secs( tt : timestr) : longint ; {returns number of secs since mid}
function secs_to_time(l : longint) : timestr;


function date: datestr;    { get system date and set variables }

procedure purge;

procedure backup(i : integer);   { backup i spaces on the tube }

procedure zap(i : integer);   { zap out i spaces and return  cursor }

procedure backzap(i : integer);

var funkey : boolean;   ext_char : integer;  { extnded key control }

function get_key : char;  { get a key and set function code if needed }
function in_range(i,j,k : integer) : boolean;  { simple range check }


procedure pause;               { wait for a CR or ESCAPE }

procedure pauseln;    { same as pause but with a new line after }

function exp10( xx : integer) : real;  { return 10 to the xx}

function rnd(xx : real; yy : integer) : real;  { round a real to yy dec places }

procedure stick(X : anystring; var Y : anystring; n : integer);

function clean_string(s : string) : string;

function power(y,x : real) : real;  { calculate y to the X power }

{ rules are if X = 0, answer = 1
            if y = 0, answer = 0
            if y < 0, answer = - of positive answer.
            if x < 0, answer is 1/ positive answer. }

function color_display : boolean;  { true if this is color }

procedure far_call(p : pointer);  { calls a pointer address like a program}

function attr(fore, back : integer) : integer;


{ the following 2 are inline macros, not real procedures }

procedure save_and_stop; inline($9c/$Fa);  { clear interupts (stop them }

procedure restore_flags; inline($9D);       { popf }

function check_8087 : small_string;
function pull_char(s :string ; i : integer) : char;
function pull_upcase(s :string ; i : integer) : char;  { upper cae versin}




{===========================================================================}

implementation


Uses
  tpCrt,
  tpstring, tpedit;

function check_8087 : small_string;
var
 m : integer;
 s : string[5];
begin
  s := '?????';
  m := test8087;
  case m of
    0 : s := 'NONE ';
    1 : s := '8087 ';
    2 : s := '80287';
    3 : s := '80387';
  end;  { case }
  check_8087 := s;
end;


procedure beep;
begin
sound(1200); delay(125); nosound; delay(125);
sound(1200); delay(125); nosound;

end;

procedure blip;
begin
  sound(1800);  delay(20); sound(900); delay(20); nosound;
end;


function date;
var
  year,month,day : string[2];
  i_y,i_m,i_d,i_dow : word;
begin                       { uses function 2A hex from MS-DOS }
  getdate(i_y,i_m,i_D,i_dow);
  i_y := i_y-1900;     { lets use a 2 digit year }
  str(i_y:2,year);     { convert bins to strings }
  str(i_d:2,day);
  str(i_m:2, month);
  month := zfill(month); day := zfill(day);

  date := month + '/'+day+'/'+year
end;    { of date function }

procedure purge;
var c : char;
begin
while keypressed do c := readkey;
end;

procedure backup;
var j : integer ;
begin
for  j := 1 to i do write(absp);
end;

procedure zap;
var j : integer;
begin
for j := 1 to i do write(' ');    { put spaces over existing chars first }
backup(i);                        { restore cursor }
end;

procedure backzap;
var j : integer;
begin
backup(i);
zap(i);
end;


function get_key;
var ch : char;
begin
  funkey := false;  ext_char := 0;  { assume no special character }
  ch := readkey;          { read and wait }
  if (ch = #27) and keypressed then begin       { one mode character }
    ch := readkey;  funkey := true;
    ext_char := ord(ch);  { save extended char }
    ch := #27;   { play like an escape came in }
  end;
  get_key := ch;
end;


procedure pause;               { wait for a CR or ESCAPE }

var
x : char;
begin
purge;
write('...[RET]...');
repeat
  x := readkey;
until (x = acr) or (x = aesc);         { wait for an actual carrige return }
backzap(11);
end;                   { simple huh ??? }

procedure pauseln;    { same as pause but with a new line after }
begin
pause;
writeln;
end;


function exp10;
var
i,j : integer;
treal  : real;

begin

  if xx = 0 then treal := 1;  { 10 to 0 = 1 }

  treal := 1;

  if xx > 0 then begin
    for i := 1 to xx do treal := treal * 10;
  end;

  if xx < 0 then begin
   j := - xx;
   for i := 1 to j do treal := treal / 10;
 end;

 exp10 := treal;
end;

function rnd;
var
i  : integer;
treal1,treal  : real;

factor : real;
begin

  if yy = 0 then begin
    treal := xx + 0.5;
    treal := int(treal);        { no decimal places }
  end;

  if yy > 0 then begin   { places to right of decimal point }
    treal1 := exp10(yy);
    treal := xx * treal1+0.5;   { move it to the left }
    treal := int(treal);
    treal := treal / treal1;  { move back to right }
  end;

  if yy < 0   then begin
    treal1 := exp10(yy);
    treal := xx * treal1 + 0.5;   { move to right }
    treal := int(treal);     { chop it off }
    treal := treal / treal1;   { move back to left }
  end;

  rnd := treal;
end;



function zfill;
  var indx, len  : integer;
  begin
   len := length(zstr);  { how much we have to fool with }
   if len <> 0 then
   begin
    indx := 1;
    repeat   { scan thru string till <> blank or end }
      if zstr[indx] = ' ' then zstr[indx] := '0';
      indx := indx+1;
    until (indx > len) or ( zstr[indx] <> ' ' );
   zfill := zstr;
   end;  { of <> length block }
  end;   { of zfill procedure }

procedure stick(X : anystring; var Y : anystring; n : integer);
var i  : integer;

begin
  i := length(x) + n;   { total length of final string }
  if length(y) < i  then  { need to extend the string }
    y := pad(y, i - length(y));
  for i := 1 to length(x) do begin
    y[i-1+n] := x[i];  { move in a single character }
  end;
end;  { of stick }


{ This will trim, case convert, and change any spaces to
  underscors.  Useful for filenames and tags
}
function clean_string(s : string) : string;
var
ss : string;
i : integer;
begin
  ss := trim(s);
  ss := stupcase(ss);
  while pos(' ',ss) <> 0 do begin
    i :=pos(' ',ss);
    ss[i] := '_';
  end;  { changing spaces }
  clean_string := ss;
end;


function power;

{ rules are if X = 0, answer = 1
            if y = 0, answer = 0
            if y < 0, answer = - of positive answer.
            if x < 0, answer is 1/ positive answer. }
var
r1,r2,r3 : real;
done : boolean;

begin
  r1 := abs(x);  r2 := abs(y);
  done := false;

  if x = 0 then begin
    r3   := 1;            { always 1 for 0 exponent }
    done := true;
  end;

  if y = 0 then begin
    r3 := 0;            { always 0 for 0 number }
    done := true;
  end;

  if not done then begin   { still need to calculate }
    r3 := exp( ln(r2) * r1);  { basic calculatin }

    if y < 0 then r3 := -1 * r3;    { negate if number < 0 }
    if x < 0 then r3 := 1/r3;       { flip over if exponent negative }
  end;

  power := r3;

end;  {  power function }



{ Convert a number of seconds into a time string }
function secs_to_time(l : longint) : timestr;
var h,m,s : integer;
  s_hour,s_min,s_sec : string[2];

begin
  h := l div 3600;     { how many hours worth of seconds}
  m := l - (h*3600);     { now many secs left after hours taken out }
  m := m div 60;       { equivalent minutes to that many seconds}
  s := l - (h*3600) - (m*60);

  str(h:2, s_hour);     { convert returned values to strings }
  str(m:2, s_min);
  str(s:2, s_sec);
  s_hour := zfill(s_hour); s_min := zfill(s_min);
  s_sec := zfill(s_sec);  { force leading 0 }
  secs_to_time := s_hour+':'+s_min+':'+s_sec;
end;


{ Return current time as number of secs since midnite }
function secs_now  : longint;  { returns number of seconds sice midnite
                                { using counter in bios memory area }
var
 r : real;
begin
  r := meml[0:$46c]  / 18.2065;
  secs_now := trunc(r);
end;

{ return current time as a string }
function time_now : timestr; { returns string using secs_now  rather than dos}
begin
  time_now := secs_to_time(secs_now);
end;


function time : timestr;
begin
  time := time_now;
end;


function num_secs( tt : timestr) : longint ; {returns number of secs from time string}

var  x,H,M,S : longint;
  t : timestr;
  ok : boolean;
begin
  t := tt;     { local copy }
  if length(t) < 8 then t := padch(t,'0', 8-length(t) );
  ok := str2long(copy(t,1,2),H); { hours first }
  if ok then ok :=  str2long(copy(t,4,2),m);  { minutes }
  if ok then ok := str2long(copy(t,7,2),s);  { secs }
  if ok then num_secs := (h*3600) + (m * 60) + s
    else num_secs := -1;  { negative nuimber is error }

end;


constructor parse_type.init;
begin
   { dummy to build object }
  primary_sep := ',';  option_sep := ' '; com_chr := ';';
end;


{ Parse as an object.  Set up the options, and then call parse.  Then
  obtain any eleent by using the methid parsed[x].  This makes it very
  similar to the old way of parsing out actual strings except that
  VAR references will not be allowed.  However, this takes up LOTS less memory

  What this does is to examine the input line and set up indexes into
  each element on the line.

  If spaces are the delimter, each element is "trimmed" by moving the
  start position to the first non space field.  This means that multiple
  spaces on the line count as a single separator.
}

procedure parse_type.parse(var instring: string);

 var
  comma, start, finish : word;
  xnay, pntr : integer ;
  double : string[2];    { check for occurance of doubles }
  i, field_num, index : integer;       { as we march across the line }
  all_done : boolean;


{ This will advance the index to the first non space char on the line}
procedure eat_spaces;
var ready : boolean;
begin
  ready :=  false;
  while ((index <= tot_len) and   (not ready)) do
    if in_buff^[index] = ' ' then inc(index)
    else ready :=  true
end;

begin
    for index := 1 to numparse do begin   { clear out the old parsed table }
      starts[index] := 0;  ends[index] := 0;
    end;

    tot_parsed  := 0;            { assume none }
    tot_len     := 0;            { length up to comment character }
    param_start := 0;            { first parameter after possible keyword}

    in_buff := @instring;        { where we will get out input from }

    if length(in_buff^) = 0 then exit;  { null line, so real simple }

    index := 1;   { current position on the line}
    start := 1;   { start of search in the buffer }

    i := pos(com_chr, in_buff^);  { see if a comment is present anywere}

    if i <> 0 then tot_len := i-1      { chop as needed }
    else tot_len := length(in_buff^);

{
  Here we decide on the field separator.  If the primary sep is found
  the it wins.  If it is not found then the secondary set wins
  Use optional separator if primary separator is not in string.
}
    comma := search(in_buff^[1], tot_len, primary_sep, 1);

    if comma <> $FFFF then sep_chr := primary_sep
    else sep_chr := option_sep;

{ Now that the seps are determined, scan the line looking for them }
    tot_parsed := 1;     { now identifying the first element }
    eat_spaces;         { move up to the first non blank char }
    starts[1] := index;  { where the first non_space char occurs }
    all_done := false;

    if index < tot_len then
    repeat  { keep looking for more entres }
      if index <= tot_len then       { not at the end as yet }
        finish := tot_len - index +1        { how much usable string is left }
      else finish := 0;   { chars left to examine }

{ search will return the number of chars SKIPPED, starting at INDEX }
      if finish <> 0 then
      comma := search(in_buff^[index], finish, sep_chr, 1)
      else comma := $ffff;  { end of the line }

      if comma = $FFFF then begin  { no more seps found }
        ends[tot_parsed] := tot_len;  { last one ends at the end of the line}
        all_done := true;
      end

      else  begin                 { we found a separator }
        index := index + comma ;  { where the next separator was on the line }
        ends[tot_parsed] := index - 1;  { finish previous field }
        inc(index);       { skip over the just found separator }
        eat_spaces;  { advance index to next non space }
{ this may bring us out to the end of the line with no mode entries }

        if index <= tot_len then begin { still more to come }
          inc(tot_parsed);  { move on to the next field }
          if tot_parsed = 2 then param_start := index;  { if starting # 2 }

          starts[tot_parsed] := index;  { start of the next field }
          ends[tot_parsed] := index;    { asssume very short field }
        end;
      end;  { finding the start of a field }

    { return to caller position of first item after keyword }

      if (index > tot_len) or (tot_parsed > numparse) then all_done := true;
    until all_done;                     { finish went to 0 meaning no more }


end;    { end of parse proc }


function parse_type.parsed(i : integer) : med_string;
begin
  if i > tot_parsed then begin
    parsed := '';  exit;
  end;

  parsed := copy(in_buff^, starts[i], ends[i]-starts[i]+1);

end;




{ Old style string based general purpose text line parser

This proc takes a string as an argument and breaks it up into smaller
pieces.  THe plan is to pull out pieces separated by sep_chr and remove
any leading or trailing blanks.

Any double occurances of a sep_chr are reduced to a single occurance
to allow multiple blanks (or whatever) tp separate entries.

a previous CONST section must define:
   numparse    - The number of elements in the parsed array
   parselen    - length of each string in the parsed array

This version will set the address of the string into the parse record
during processing.  It is not assumed to be correct in the record
prior to entry.

}
(*

procedure parse( var instring : string; var par_rec : parse_rec);  { general purpose parser}

 var
  xnay, comma, pntr, indx, len, start, finish   : integer ;   { locals }
  buf  : anystring;
  double : string[2];    { check for occurance of doubles }

begin

    for indx := 1 to numparse    { clear out the old parsed table }
      do  parsed[indx] := '';

    tot_parsed := 0;             { assume none }
    param_start := 0;

    in_buff := @instring;
    buf := trim(in_buff^);   { get a local copy  of original}
    if pos(com_chr, buf) <> 0 then
      buf := copy(buf,1,pos(com_chr, buf)-1);  { strip comment }

{ use optional separator if primary separator is not in string }
    if pos(primary_sep, buf) <> 0 then
      sep_chr := primary_sep
    else
      sep_chr := option_sep;

{ check for all double separaters and reduce them to a single if the
  separator is a blank }

    if sep_chr = ' ' then begin
      double := sep_chr + sep_chr;
      repeat
        comma := pos( double, buf);   { any doubles left }
        if comma <> 0 then delete(buf, comma, 1);  { get rid of sep char}
      until comma = 0;
    end

{ check for all double separators and insert a space between them if the
  separator is not a blank }

    else begin
      double := sep_chr + sep_chr;
      repeat
        comma := pos( double, buf);                       { any doubles left }
        if comma <> 0 then insert(' ', buf, comma+1);   { get rid of sep char}
      until comma = 0;
    end;

    len := length(buf);                            { total chars to scan thru }
    if len <> 0 then  begin                        { dont process blank lines }
      indx:=1;                  { keeps track of parsed result array position }
      start := 1;                                { start at beginning of line }

      repeat                                        { up to 10 entries or len }
        comma := pos(sep_chr, copy(buf,start,len));  { comma loc relative to start }
        finish := start+comma-1;                      { comma relative to buf }

        if comma <> 0 then
          parsed[indx] := copy(buf,start, finish-start)   { raw grab from buf}
        else
          parsed[indx] := copy(buf,start,len);           { grab rest of line }

        parsed[indx] := trim(parsed[indx]);   { get rid of leading and trailing blanks }

      { return to caller position of first item after keyword }
        if indx = 2 then
          param_start := start;

        start := finish+1;                              { skip over the comma }
        tot_parsed := indx;                    { global count of total parsed }
        indx := indx + 1;                        { next parsed array location }
      until (comma = 0 ) or (start > len) or (indx > numparse);
                                           { finish went to 0 meaning no more }
    end;                                         { of non blank line to parse }


*)

function color_display : boolean; { return tue if in color mode }
var
  Reg        : Registers;
  colorcard  :boolean;

begin
  Reg.AH := 15;
  Intr($10, Reg);
  ColorCard := Reg.AL <> 7;
  if ColorCard then
    color_display := true
  else
    color_display := false;
end;


procedure far_call(p : pointer);  { calls non nill address }
var
  a_loc : pointer;
begin
  a_loc := p;
  if a_loc <> nil then
  inline ($36/$ff/$9E/>a_loc);  { ss: call far [a_loc]bp }
end;


function attr;
var
  temp : byte;
begin
  temp := (back*16)+fore;
  if fore > 15 then temp := temp + 112;
  attr := temp;
end;

function in_range(i,j,k : integer) : boolean;  { simple range check }

begin
  in_range := (i >= j) and (i <= k);
end;

function pull_char(s :string ; i : integer) : char;
begin
  if i <= length(s) then pull_char := s[i] else pull_char := #0;
end;

function pull_upcase(s :string ; i : integer) : char;
var c : char;
begin
  if i <= length(s) then begin
    c := s[i] ; pull_upcase := upcase(C)
  end
  else pull_upcase := #0;
end;


begin
end.